(*  By David Mundie for Culinary Software Systems.  *)
(*  Types four lines of 32 characters on a hard-copy device.  *)

{   Modified 21 July 1981 by Jim Gagne...Now it 
      a) works on my system,
      b) has meaningful variable & constant names,
      c) fills in more than just a 5x7 matrix, by adding partial dots to fill 
         in diagonals, and 
      d) allows up to 4-size letters just by printing everything up to 4 times.
      
    You'll want to fiddle with this to get it going, as I've changed some 
    things around (eg, adding nulls so as not to overwhelm my printer).
    
    REQUESTS:
      a) increase matrix to a more ample size (at least 7x9)
      b) bring in letter matrix definitions from a file, so we can print block,
         Old English, Roman, etc., letters at a whim.  BEST would be a letter-
         definition program that allowed letter matrices to be entered
         interactively and with character graphics (eg, 7x9 matrix of dots
         on the screen, where a dot would show as "X").
}

PROGRAM banner;
CONST   AbsMaxLine = 5;          {Maximum lines of text - 1}
        MaxChPerLn = 31;         {Max chars per line - 1}
        ColPerCh = 5;            {Columns of dots per character}
        ColPChM1 = 4;            {above -1}
        RowPerCh = 8;            {Rows of dots per character}
        RowPChM1 = 7;            {above -1}
        MaxPixels = 39;          {Dots per character (RowPerCh X ColPerCh -1)}
        HasDiablo = true;        {if so, uses 1/2 linefeeds to fill in char's}

TYPE    pixel = 0..MaxPixels;    {MOD ColPerCh = Column; DIV RowPerCh = Row}
{SO a character grid (upright) looks like:  0  1  2  3  4
...and on its side (the                     5  6  7  8  9
   way it's printed):                      10 11 12 13 14
35 30 25 20 15 10  5  0                    15 16 17 18 19
36 31 26 21 16 11  6  1                    20 21 22 23 24
37 32 27 22 17 12  7  2 (top)              25 26 27 28 29
38 33 28 23 18 13  8  3                    30 31 32 33 34
39 34 29 24 19 14  9  4                    35 36 37 38 39   }

        pixset = set of pixel;

VAR     c: char;
        MaxLine, LinesTyped, n, m: integer;
        SizeFactor: 1..10;
        filename: string;
        message: ARRAY [0..AbsMaxLine,0..MaxChPerLn] OF pixset;
        textin: ARRAY [0..AbsMaxLine] OF string;
        table : ARRAY [' '..'z'] OF pixset;
        list: text;


PROCEDURE initialize;
BEGIN
  table['!'] := [2,7,12,17,32];
  table['A'] := [1..3,5,10,9,14,15..19,20,25,30,24,29,34];
  table['B'] := [0..3,5,10,9,14,15..18,20,25,30,24,29,30..33];
  table['C'] := [1..3,5,10,15,20,25,31..33,29,9];
  table['D'] := [0..2,5,10,15,20,25,30..32,28,24,19,14,8];
  table['E'] := [0..4,5,10,15..19,20,25,30..34];
  table['F'] := [0..4,5,10,15..18,20,25,30];
  table['G'] := [1..4,5,10,15,20,25,31..34,29,24,18..19];
  table['H'] := [0,5,10,15,20,25,30,4,9,14,19,24,34,29,16..18];
  table['I'] := [1..3,7,12,22,17,12,27,31..33];
  table['J'] := [0..4,8,13,18,23,28,31..32,25];
  table['K'] := [0,5,10,15,20,25,30,16,12,8,4,22,28,34];
  table['L'] := [0,5,10,15,20,25,30..34];
  table['M'] := [0,5,10,15,20,25,30,4,9,14,19,24,29,34,6,8,12,17];
  table['N'] := [0,5,10,15,20,25,30,4,9,14,19,24,29,34,11,17,23];
  table['O'] := [1..3,31..33,5,10,15,20,25,9,14,19,24,29];
  table['P'] := [0..3,5,10,15,20,25,30,16..18,14,9];
  table['Q'] := [1..3,5,10,15,20,25,31,32,34,28,22,24,19,14,9,4];
  table['R'] := [0..3,5,9,10,14,19,15..18,20,25,30,22,28,34];
  table['S'] := [1..4,30..33,16..18,5,10,24,29];
  table['T'] := [0..4,7,12,17,22,27,32];
  table['U'] := [0,5,10,15,20,25,31..33,29,24,19,14,9,4];
  table['V'] := [0,5,10,15,20,26,32,28,24,19,14,9,4];
  table['W'] := [0,5,10,15,20,25,31,33,27,22,17,29,24,19,14,9,4];
  table['X'] := [0,5,25,30,4,9,29,34,21,17,13,11,17,23];
  table['Y'] := [0,5,10,16,22,27,32,18,14,9,4];
  table['Z'] := [0..4,30..34,25,21,17,13,9];
  table[' '] :=[];
  
  table['a'] := [11..14,19,21..24,25,29,31..34];
  table['b'] := [0,5,10,20,25,15..18,30..33,24,29];
  table['c'] := [11..13,15,20,25,31..33];
  table['d'] := [4,9,14,15,16..19,31..34,20,25,24,29];
  table['e'] := [11,12,15,18,20..23,25,31,32];
  table['f'] := [2,6,8,11,15..17,21,26,31];
  table['g'] := [11,12,15,18,20,23,26..28,33,36,37];
  table['h'] := [0,5,10,15,20,25,30,16,17,23,28,33];
  table['i'] := [7,16,17,22,27,31..33];
  table['j'] := [8,18,23,28,33,31,37];
  table['k'] := [0,5,10,15,20,25,30,21,17,27,33];
  table['l'] := [1,2,7,12,17,22,27,31..33];
  table['m'] := [11,13,15,17,19,20,22,24,25,29,30,34];
  table['n'] := [11,12,15,18,20,23,25,28,30,33];
  table['o'] := [11,12,15,18,20,23,25,28,31,32];
  table['p'] := [10..12,15,18,20,23,25..27,30,35];
  table['q'] := [11..13,15,18,20,23,26..28,33,38,39];
  table['r'] := [10,12,13,15,16,20,25,30];
  table['s'] := [11..13,15,21..23,29,31..33];
  table['t'] := [6,10..12,16,21,26,32];
  table['u'] := [10,13,15,18,20,23,25,28,31..34];
  table['v'] := [10,14,15,19,20,24,26,28,32];
END;


PROCEDURE Init2;
BEGIN
  table['w'] := [10,14,15,17,19,20,22,24,25,27,29,31,33];
  table['x'] := [10,14,16,18,22,26,28,30,34];
  table['y'] := [10,13,15,18,20,23,26..28,33,36,37];
  table['z'] := [10..14,18,22,26,30..34];
  table['-'] := [16,17,18];
  table['*'] := [7,12,17,22,27,16,18,10,14,20,24];
  table['?'] := [1..3,5,9,13,17,22,32];
  table['.'] := [29,34];
  table[','] := [28,33,37];
  table[':'] := [12,17,27,32];
  table[';'] := table[':'] + [36];
END;


PROCEDURE Show;
VAR     i,CCount,Col,Lines,Row, Size:integer;
        maxlen:integer;


PROCEDURE WriteDot;
VAR     x, y: integer;
BEGIN
  FOR y := 1 TO SizeFactor DO
    BEGIN
      Write(list,'%',CHR(8),'M',CHR(8),'#');
      IF HasDiablo THEN FOR x := 1 TO 8 DO Write(list,CHR(0))
    END
END;


PROCEDURE WriteBlank;
VAR     i: integer;
BEGIN FOR i := 1 TO SizeFactor DO Write(List, ' ') END;


FUNCTION FillLeft: boolean;
VAR     x,              {current pixel}
        y: integer;     {1 pixel to left}
        TCh: pixset;
BEGIN
  IF Row >= RowPChM1 THEN FillLeft := false
  ELSE BEGIN
    TCh := message[Lines,CCount];  x := Row*ColPerCh + Col;  y := x + ColPerCh;
    IF NOT(y IN TCh) THEN FillLeft := false
    ELSE IF Col <= 0 THEN FillLeft := ((x + 1) IN TCh) AND NOT ((y + 1) IN TCh)
    ELSE IF Col >= ColPChM1
      THEN FillLeft := ((x - 1) IN TCh) AND NOT ((y - 1) IN TCh)
    ELSE FillLeft := (((x + 1) IN TCh) AND NOT ((y + 1) IN TCh))
      OR (((x - 1) IN TCh) AND NOT ((y - 1) IN TCh))
  END
END;


FUNCTION FillRight: boolean;
VAR     x,              {current pixel}
        y: integer;     {1 pixel to right}
        TCh: pixset;
BEGIN
  IF Row <= 0 THEN FillRight := false
  ELSE BEGIN
    TCh := message[Lines,CCount];  x := Row*ColPerCh + Col;  y := x - ColPerCh;
    IF NOT(y IN TCh) THEN FillRight := false
    ELSE IF Col <= 0 THEN FillRight := ((x + 1) IN TCh) AND NOT ((y + 1) IN TCh)
    ELSE IF Col >= ColPChM1
      THEN FillRight := ((x - 1) IN TCh) AND NOT ((y - 1) IN TCh)
    ELSE FillRight := (((x + 1) IN TCh) AND NOT ((y + 1) IN TCh))
      OR (((x - 1) IN TCh) AND NOT ((y - 1) IN TCh))
  END
END;

    
BEGIN
  maxlen := 0;
  FOR i := 0 TO LinesTyped-1 DO
    IF length(textin[i]) > maxlen THEN maxlen := length(textin[i]);
  FOR CCount := 1 TO maxlen DO          {write each column of characters}
    BEGIN
      FOR Col := 0 TO 4 DO FOR Size := 1 TO SizeFactor DO {write dot col's}
        BEGIN
          FOR Lines := LinesTyped-1 DOWNTO 0 DO
            BEGIN
              FOR Row := 7 DOWNTO 0 DO
                BEGIN
                  IF Row * ColPerCh + Col IN message[Lines,CCount]
                    THEN FOR i := 1 TO 2 DO WriteDot
                  ELSE IF FillLeft THEN BEGIN WriteDot;  WriteBlank END
                  ELSE IF FillRight THEN BEGIN WriteBlank;  WriteDot END
                  ELSE FOR i := 1 TO 2 DO WriteBlank
                END;
              FOR i := 1 TO 2 DO WriteBlank  {space between lines}
            END;
          IF HasDiablo THEN FOR i := 1 TO 20 DO Write(List,CHR(0));
          Writeln(list)
        END;
      FOR Size := 1 TO SizeFactor DO Writeln(list)
    END;
END;


BEGIN
  FOR n := 0 TO AbsMaxLine DO
    BEGIN
      FOR m := 0 TO 31 DO message[n,m] := [];  textin[n] := ''
    END;
  Initialize;  Init2;  SizeFactor := 1;
  Write(
'By what factor (1 to 4) do you wish to multiply the size of the letters? ');
  Readln(SizeFactor);  MaxLine := AbsMaxLine DIV SizeFactor + 1;
  Writeln(
    'Enter your message (up to ',MaxLine,' lines of up to 32 characters): ');
  n := 0;  
  REPEAT
    Readln(textin[n]);  m := Length(textin[n]);
    IF m > MaxChPerLn THEN DELETE(Textin[n],MaxChPerLn, m - MaxChPerLn + 1);
    n := n + 1
  UNTIL (n > MaxLine) OR (textin[n-1] = ' ') OR (textin[n-1] = '');
  IF (textin[n-1] = ' ') OR (textin[n-1] = '')
    THEN LinesTyped := n-1 ELSE LinesTyped := n;
  Write('Please enter name of output ->  ');  Readln(filename);
{$I-}
  Rewrite(list,filename);
  IF IORESULT > 0 THEN Rewrite(list,concat(filename,'.text'));
{$I-}
  IF IORESULT > 0 THEN Write('Can''t open that file.')
  ELSE BEGIN
    FOR n := 0 TO LinesTyped-1 DO FOR m := 1 TO length(textin[n]) DO
      message[n,m] := table[textin[n,m]];
    Show;
    CLOSE(list,lock);
  END
END.

